#!/bin/sh
exec "${GUILE:-guile}" -e "(@ (explore) guix-explore)" -s "$0" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (explore)
  #:use-module (gnu)
  #:use-module (guix)
  #:use-module (guix i18n)
  #:use-module (gnu services)
  #:autoload   (gnu services desktop) (%desktop-services)
  #:use-module (guix gexp)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (json)
  #:use-module (sxml simple)
  #:autoload   (syntax-highlight) (highlight highlights->sxml)
  #:autoload   (syntax-highlight scheme)
               (make-scheme-lexer %default-special-symbols)
  #:autoload   (texinfo) (texi-fragment->stexi)
  #:autoload   (texinfo html) (stexi->shtml)
  #:autoload   (ice-9 pretty-print) (truncated-print)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web server)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:autoload   (ice-9 ftw) (scandir)
  #:autoload   (ice-9 pretty-print) (pretty-print)
  #:export (guix-explore)
  #:declarative? #f)                              ;for Geiser

;;; Commentary:
;;;
;;; Serve a web page that provides an interactive view of the services of a
;;; system.
;;;
;;; Code:

(define* (not-found request
                    #:key (phrase "Resource not found")
                    ttl)
  "Render 404 response for REQUEST."
  (values (build-response #:code 404
                          #:headers (if ttl
                                        `((cache-control (max-age . ,ttl)))
                                        '()))
          (string-append phrase ": "
                         (uri-path (request-uri request)))))

(define (request-path-components request)
  "Split the URI path of REQUEST into a list of component strings.  For
example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
  (split-and-decode-uri-path (uri-path (request-uri request))))

(define (render-home-page request)
  (values '((content-type . (text/html (charset . "UTF-8"))))
          (call-with-output-string
            (lambda (port)
              (sxml->xml `(html
                           (head (title "GNU Guix System Explorer")
                                 (link (@ (rel "stylesheet")
                                          (type "text/css")
                                          (href "/static/css/style.css")))
                                 (link (@ (rel "stylesheet")
                                          (type "text/css")
                                          (href "/static/css/code.css"))))

                           (body
                            (h1 "Exploring Your System!")

                            (div (@ (id "container") (class "svg-container"))
                                 ;; (svg (@ (id "graph")))
                                 )

                            (script (@ (type "text/javascript")
                                       (src "/static/js/d3.v6.js"))
                                    "script")
                            (script (@ (type "text/javascript")
                                       (src "/static/js/graph.js"))
                                    "script")))
                         port)))))

(define (service-node-id service)
  "Return an identifier for SERVICE, then used to uniquely identify it in the
serialized JSON representation of the graph."
  (string-append (symbol->string (service-type-name (service-kind service)))
                 "-"
                 (number->string (object-address service) 16)))

(define (service-html-description service)
  "Return the localized description of SERVICE's type as HTML."
  (call-with-output-string
    (lambda (port)
      (sxml->xml (stexi->shtml
                  (texi-fragment->stexi
                   (match (service-type-description (service-kind service))
                     (#f "")
                     (str (P_ str)))))
                 port))))

(define* (render-nodes request services
                       #:key (category (const 'base)))
  "Respond to REQUEST by rendering SERVICES as a set of graph nodes, as
JSON."
  (define (service->json-node service)
    `((id . ,(service-node-id service))
      (label . ,(symbol->string
                 (service-type-name (service-kind service))))
      (category . ,(category service))
      (description . ,(service-html-description service))))

  (values '((content-type . (application/json (charset . "UTF-8"))))
          (scm->json-string
           (list->vector
            (map service->json-node services)))))

(define service-back-edges
  (@@ (gnu services) service-back-edges))

(define (render-edges request services)
  "Respond to REQUEST by rendering the edges among SERVICES as JSON."
  (define back-edges
    (service-back-edges services))

  (define (service->edges service)
    (map (lambda (dependent)
           `((target . ,(service-node-id service))
             (source . ,(service-node-id dependent))))
         (back-edges service)))

  (values '((content-type . (application/json (charset . "UTF-8"))))
          (scm->json-string
           (list->vector
            (append-map service->edges services)))))

(define (at-most max-length lst)              ;from (guix scripts substitute)
  "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
  (let loop ((len 0)
             (lst lst)
             (result '()))
    (match lst
      (()
       (values (reverse result) '()))
      ((head . tail)
       (if (>= len max-length)
           (values (reverse result) lst)
           (loop (+ 1 len) tail (cons head result)))))))

(define (store-link file)
  "Return SHTML containing a link to FILE, a file in the store."
  (define store-prefix-len
    (+ (string-length (%store-prefix))
       32 2))

  `(a (@ (href ,(store-file-url file))
         (class "store-link"))
      ,(string-append (%store-prefix) "/…-"
                      (string-drop file store-prefix-len))))

(define (link-store-items sxml)
  "Recurse over SXML and syntax-highlight code snippets."
  (define min-length
    (+ (string-length (%store-prefix)) 32 1))

  (define (quoted-string? str)
    (and (string-prefix? "\"" str)
         (string-suffix? "\"" str)))

  (match sxml
    ((tag ('@ attributes ...) body ...)
     `(,tag (@ ,@attributes) ,@(map link-store-items body)))
    ((tag body ...)
     `(,tag ,@(map link-store-items body)))
    ((? string? str)
     (if (quoted-string? str)
         (let ((unquoted (string-drop (string-drop-right str 1) 1)))
           (if (and (store-path? unquoted)
                    (> (string-length unquoted) min-length))
               `("\"" ,(store-link unquoted) "\"")
               str))
         str))))

(define* (value->shtml store value
                       #:key (limit 20))
  "Render VALUE, an arbitrary Scheme value (a service value),
as SHTML.  Display at most LIMIT elements for lists."
  ;; Note: If the author was versed in JavaScript, they'd send the value as
  ;; JSON to the browser, and let JS code in the browser present it.  But
  ;; hey, SXML is so comfortable!
  (define scheme-lexer
    (make-scheme-lexer %default-special-symbols
                       '("define" "syntax")))

  (define (object->pretty-string obj)
    (call-with-output-string
      (lambda (port)
        (pretty-print obj port #:width 50))))

  (define (highlight-scheme str)
    (link-store-items
     (highlights->sxml (highlight scheme-lexer str))))

  (match value
    ((? package? package)
     `(a (@ (href ,(string-append "https://hpc.guix.info/package/"
                                  (package-name package))))
         ,(package-full-name package)))
    ((? file-like? file)
     ;; Clever trick: use 'lower-gexp' to combine lowering and expansion;
     ;; 'lower-object' would get expansion wrong for 'file-append' and such.
     (match (lowered-gexp-sexp (run-with-store store
                                 (lower-gexp #~(-> #$file))))
       (('-> (? string? file))
        `(span "\"" ,(store-link file) "\""))))
    ((? gexp? gexp)
     (let ((sexp (lowered-gexp-sexp (run-with-store store
                                      (lower-gexp gexp)))))
       `(pre (@ (class "scheme-value"))
             ,(highlight-scheme (object->pretty-string sexp)))))
    ((? struct? record)
     (let ((rtd (record-type-descriptor record)))
       `(div (@ (class "scheme-record"))
             ,@(map (lambda (field)
                      `(div (@ (class "scheme-record-field"))
                            (span (@ (class "scheme-record-field-name"))
                                  ,field)
                            (span (@ (class "scheme-record-field-value"))
                                  ,(value->shtml
                                    store
                                    ((record-accessor rtd field) record)
                                    #:limit limit))))
                    (record-type-fields rtd)))))
    ((lst ...)
     (let ((lst tail (at-most limit lst)))
       `(span (@ (class "scheme-list")) "("
              ,@(map (lambda (item)
                       `(span (@ (class "scheme-list-element"))
                              ,(value->shtml store item #:limit limit)))
                     lst)
              ,@(if (null? tail)
                    '()
                    `((span (@ (class "scheme-list-ellipsis"))
                            "…")))
              ")")))
    ((? array? array)                             ;string, bytevector, etc.
     (let ((str (call-with-output-string
                  (lambda (port)
                    (truncated-print array port
                                     #:width 50)))))
       `(pre (@ (class "scheme-value"))
             ,(highlight-scheme str))))
    ;; TODO: Add 'plain-file', etc.
    (x
     `(pre (@ (class "scheme-value"))
           ,(highlight-scheme (object->pretty-string x))))))

(define (query-parameters str)
  "Return an alist corresponding to the query parameter string STR, a string
like \"?x=a%20b&y=42\"."
  (define not-equal
    (char-set-complement (char-set #\=)))
  (define not-question-ampersand
    (char-set-complement (char-set #\? #\&)))

  (filter-map (lambda (key=value)
                (match (string-tokenize key=value not-equal)
                  ((key value)
                   (cons (string->symbol (uri-decode key))
                         (uri-decode value)))
                  (_ #f)))
              (string-tokenize str not-question-ampersand)))

(define* (request-query-parameter request parameter
                                  #:optional (default #f))
  "Return the PARAMETER query parameter of REQUEST, where PARAMETER is a
symbol, or DEFAULT if PARAMETER was not given."
  (define parameters
    (or (and=> (uri-query (request-uri request)) query-parameters)
        '()))

  (or (assoc-ref parameters parameters)
      default))

(define (render-node-value request store services id)
  "Render as JSON the value of the service with the given ID among SERVICES."
  (define limit
    (or (and=> (request-query-parameter request 'limit) string->number)
        20))

  (match (find (lambda (service)
                 (string=? (service-node-id service) id))
               services)
    (#f (not-found request))
    (service
     (values '((content-type . (text/html (charset . "UTF-8"))))
             (call-with-output-string
               (lambda (port)
                 (sxml->xml (value->shtml store (service-value service)
                                          #:limit limit)
                            port)))))))

(define (render-edge-value request store services source-id target-id)
  "Render the value of the edge from SOURCE-ID to TARGET-ID."
  (define limit
    (or (and=> (request-query-parameter request 'limit) string->number)
        20))

  (define (matching-id? id)
    (lambda (service)
      (string=? (service-node-id service) id)))

  (define source
    (find (matching-id? source-id) services))

  (define target
    (find (matching-id? target-id) services))

  (if (and source target)
      (let* ((extension (find (lambda (extension)
                                (eq? (service-extension-target extension)
                                     (service-kind target)))
                              (service-type-extensions
                               (service-kind source))))
             (compute   (service-extension-compute extension))
             (value     (compute (service-value source))))
        (values '((content-type . (text/html (charset . "UTF-8"))))
                (call-with-output-string
                  (lambda (port)
                    (sxml->xml (value->shtml store value #:limit limit)
                               port)))))
      (not-found request)))

(define (render-file request file)
  (let* ((file (string-append (dirname (current-filename))
                              "/" (basename file)))
         (mime-type (cond ((string-suffix? ".js" file)
                           '(text/javascript))
                          ((string-suffix? ".css" file)
                           '(text/css))
                          (else
                           '(application/octet-stream)))))
    (if (file-exists? file)
        (values `((content-type . ,mime-type))
                (call-with-input-file file
                  get-bytevector-all))
        (not-found request))))

(define (store-file-url file)
  "Return a URI reference for FILE, a store file."
  (uri->string
   (build-uri-reference #:path (string-append "/store" file))))

(define (render-directory directory)
  (values '((content-type . (text/html (charset . "UTF-8"))))
          (call-with-output-string
            (lambda (port)
              (sxml->xml
               `(html
                 (head (title "Directory Listing"))
                 (body
                  (h1 (tt ,directory))

                  (ul
                   ,@(map (lambda (file)
                            (let ((full (string-append directory "/" file)))
                              `(li (a (@ (href ,(store-file-url full)))
                                      (tt ,file)))))
                          (scandir directory
                                   (match-lambda
                                     ((or "." "..") #f)
                                     (_ #t)))))))
               port)))))

(define %text-extensions
  ;; Extensions of text files.
  '("rc" ".txt" ".org" ".scm" ".js" ".conf" ".cnf" "_config"
    "motd" ".service" "-mcron-job" ".rules" "fstab"))

(define (render-store-item request file)
  "Render FILE, a store item."
  (if (and (store-path? file) (file-exists? file))
      (if (file-is-directory? file)
          (render-directory file)
          (let ((mime (if (any (cut string-suffix? <> file)
                               %text-extensions)
                          '(text/plain)           ;unknown charset?
                          '(application/octet-stream))))
            (values `((content-type . ,mime))
                    (call-with-input-file file
                      get-bytevector-all))))      ;FIXME: argh!

      ;; TODO: If there's a deriver for FILE, add a "build" button.
      (not-found request)))


;; State of what's currently represented.
(define-record-type <view>
  (view user essential initial services previous)
  view?
  (user       view-user-services)
  (essential  view-essential-services)
  (initial    view-initial-services)
  (services   view-services)
  (previous   view-previous-view))

(define-syntax-rule (thread-state exp state ...)
  (call-with-values
      (lambda ()
        exp)
    (lambda (response body . rest)
      (apply values response body (append rest (list state ...))))))

(define (compute-folding services root)
  "Fold SERVICES to ROOT (a service).  Return the updated root along with the
remaining services--i.e., those that have not been folded."
  (define updated-root
    (fold-services services
                   #:target-type (service-kind root)))

  (define back-edges
    (service-back-edges services))

  (define dependents
    (let loop ((nodes (list root))
               (result '()))
      (match nodes
        (() result)
        (nodes (loop (append-map back-edges nodes)
                     (append nodes result))))))

  (values (cons updated-root
                ;; FIXME: Remove the edges to ROOT rather than all of
                ;; DEPENDENTS.
                (remove (lambda (service)
                          (memq service dependents))
                        services))
          updated-root))

(define (render-folding request view id)
  "Respond to REQUEST, which is about folding services to ID."
  (define root
    (find (lambda (service)
            (string=? (service-node-id service) id))
          (view-services view)))

  (let ((services updated-root (compute-folding (view-services view)
                                                root)))
    (values '((content-type . (application/json (charset . "UTF-8"))))
            ;; Return the ID of UPDATED-ROOT so it can be highlighted.
            (scm->json-string
             `((id . ,(service-node-id updated-root))))
            (set-fields view
                        ((view-services) services)
                        ((view-previous-view) view)))))

(define (render-previous-view request view)
  "Respond to REQUEST by restoring the previous view--IOW, \"undoing\" the
latest changes."
  (if (view-previous-view view)
      (values (build-response #:code 200)
              "Undone!"
              (view-previous-view view))
      (values (build-response #:code 404
                              #:reason-phrase "Nothing to undo.")
              ""
              view)))

(define (render-initial-view request view)
  "Respond to REQUEST by restoring the initial view."
  (values (build-response #:code 200)
          "Reset!"
          (set-fields view
                      ((view-services)
                       (view-initial-services view))
                      ((view-previous-view)
                       #f))))

(define (handle-request request body view store)
  (define (service-category service)
    (cond ((memq service (view-essential-services view))
           'essential)
          ((memq service %base-services)     'base)
          ((memq service %desktop-services)  'desktop)
          (else                              'user)))

  (define services
    (view-services view))

  (pk 'req (request-method request)
      (uri->string (request-uri request)))
  (if (eq? 'GET (request-method request))
      (match (request-path-components request)
        ((or () ("index.html"))
         (thread-state (render-home-page request) view store))
        (("static" _ ... file)
         (thread-state (render-file request file) view store))
        (("store" file ...)
         (thread-state (render-store-item request
                                          (string-join file "/" 'prefix))
                       view store))
        (("edges")
         (thread-state (render-edges request services)
                       view store))
        (("nodes")
         (thread-state (render-nodes request services
                                     #:category service-category)
                       view store))
        (("value" id)
         (thread-state (render-node-value request store services id)
                       view store))
        (("edge" source target)
         (thread-state (render-edge-value request store
                                          services source target)
                       view store))
        (("fold" id)
         (thread-state (render-folding request view id)
                       store))
        (("undo")
         (thread-state (render-previous-view request view)
                       store))
        (("reset")
         (thread-state (render-initial-view request view)
                       store))
        (("quit")
         (throw 'quit 1))
        (_
         (thread-state (not-found request) view store)))
      (thread-state (not-found request) view store)))

(define* (run-explore-server os #:key (port 8080))
  (define user-services
    (operating-system-user-services os))

  (define essential-services
    (operating-system-essential-services os))

  (define services
    (instantiate-missing-services
     (append user-services essential-services)))

  (info (G_ "Open a browser at ~a and start exploring!~%")
        (string-append "http://localhost:" (number->string port)))
  (with-store store
    (run-server handle-request (lookup-server-impl 'http)
                `(#:port ,port)
                (view user-services essential-services
                      services services #f)
                store)))

(define (guix-explore args)
  (define %user-module                     ;copied from (guix scripts system)
    ;; Module in which the machine description file is loaded.
    (make-user-module '((gnu system)
                        (gnu services)
                        (gnu system shadow))))

  (with-error-handling
    (match args
      ((_ file)
       (run-explore-server (load* file %user-module)))
      (_
       (leave (G_ "Usage: explore FILE~%"))))))
